home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr51
/
lib201.zip
/
WINDOWS.PRG
< prev
Wrap
Text File
|
1993-02-23
|
61KB
|
1,610 lines
*-------------------------------------------------------------------------------
*-- Program...: WINDOWS.PRG
*-- Programmer: Ken Mayer (CIS: 71333,1030)
*-- Date......: 02/23/1993
*-- Notes.....: This set of functions was published in the JUNE, 1992 issue of
*-- Technotes for dBASE IV (Vol. 90). The routines were created
*-- by Adam Menkes, except for the ones added in (used by a couple
*-- of the functions) that were written by Jay Parsons.
*-- For a complete explanation on how these routines work, you need
*-- to read the article in TechNotes. I have entered the routines,
*-- and added the standard DUFLP notation at the beginning, and
*-- once this issue of TN has been posted on the BORBBS, this file
*-- will be added to the 'current' version of LIBxx.ZIP.
*-------------------------------------------------------------------------------
FUNCTION Alert
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: This routine creates a popup on the screen with a title and
*-- one line message, forcing the user to notice the message.
*-- The user must use the mouse on the 'OK' pad, press <Esc> or
*-- press <Enter> to move on in the program that called this
*-- function.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/19/1992 - Modified to accept the <Enter> key by Ken Mayer,
*-- also a bit better cleanup at the end (releasing things from
*-- memory, and so on).
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Alert("<cTitle>","<cMessage>")
*-- Example.....: lX = Alert("Print Aborted","You pressed <ESC>")
*-- Returns.....: Logical
*-- Parameters..: cTitle = Title line
*-- cMessage = One line message (up to 79 characters)
*-------------------------------------------------------------------------------
parameters cTitle, cMessage
private wWindow,nRow,nCol,mPad
wWindow = WINDOW() && save current Window
save screen to sTemp && save the screen
activate screen
nRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8) && center from top-bottom
nCol = 38 - (max(len(cTitle),len(cMessage))/2) && center left-right
nCol2 = max(len(cTitle),len(cMessage)) && right side?
*-- clear out a section of the screen
@nRow,nCol Clear to nRow+6,nCol+nCol2
*-- fill in a box
@nRow,nCol Fill to nRow+6,nCol+nCol2+1 color n+ && grey
*-- put a double line border around box
@nRow,nCol to nRow+6,nCol+nCol2+1 double color bg+
*-- display title
@nRow + 1,nCol + 1 + iif(len(cTitle) > len(cMessage),0,;
(len(cMessage)-len(cTitle)) / 2) say cTitle color w+/n
*-- display line
@nRow + 2, nCol + 1 to nRow + 2, nCol + nCol2 color bg+
*-- display message
@nRow + 3, nCol+1+iif(len(cTitle) > len(cMessage),;
(len(cTitle)-len(cMessage)) / 2, 0) say cMessage color w+/n
*-- define/display a very small menu (one pad)
define menu mAlert
define pad pPad1 of mAlert prompt " OK " at nRow +5,37
on selection pad pPad1 of mAlert deactivate menu
*-- added by Ken to deal with <Enter>
on key label ctrl-M keyboard "{27}"
*-- start it up
activate menu mAlert
*-- deal with user 'input'
mPad = pad()
*-- restore environment, free up RAM by releasing things
on key label ctrl-m
restore screen from sTemp
release screen sTemp
release menu mAlert
if "" # wWindow
activate window &wWindow
endif
RETURN .not. "" = mPad && not empty pad?
*-- EoF: Alert()
FUNCTION CheckBox
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: This routine brings up a one-line message, allows the user
*-- to click mouse/press <Space> on it, to change status.
*-- Pressing <Enter>/<Esc> chooses the current setting ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: CheckBox(<lVar>,"<cTitle>",<nRow>,<nCol>,<nASCII>)
*-- Example.....: lX = CheckBox(.t.,"OK as is?",9,10,4)
*-- Returns.....: Logical
*-- Parameters..: lVar = On or Off to start? (.t.=on, .f.=off)
*-- cTitle = Title/Message
*-- nRow = Row to place this
*-- nCol = Column ...
*-- nASCII = ascii character to use in box. (Optional)
*-- Default is 251 (√). Other suggestions include:
*-- 4 (diamond), 176 (░), 177 (▒), 178 (▓),
*-- 219 (█), 249 (∙), 250 (·), 254 (■)
*-- (Check out the ASCII chart in the language ref.)
*-------------------------------------------------------------------------------
parameters lVar, cTitle, nRow, nCol, nASCII
*-- if parameter is left blank, assign 251 (√)
nASCII = iif(pCount() = 5, nASCII, 251)
define menu mCheck
*-- loop until user does something, or presses <Esc>
do while .t.
*-- define the menu pad ...
define pad pCheck1 of mCheck at nRow,nCol prompt;
"["+iif(lVar,chr(nASCII)," ")+"] "+cTitle
on selection pad pCheck1 of mCheck deactivate menu
*-- when user presses <Enter> turn it all off ... (send <Esc> ...)
on key label ctrl-m keyboard "{27}"
*-- start 'er up
activate menu mCheck
*-- (<Esc> or <Enter>)
if lastkey() = 27
exit
endif
lVar = .not. lVar && set to opposite of current setting
enddo
*-- reset environment/release things
on key label ctrl-m
release menu mCheck
RETURN lVar
*-- EoF: CheckBox()
Function CheckBx1
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: This routine brings up a one-line message, allows the user
*-- to click mouse/press <Space> on it, to change status.
*-- Pressing <Enter>/<Esc> chooses the current setting ...
*-- This one is different, in that it does not use a menu to
*-- accomplish it's ends, but uses instead a memvar, with
*-- @/GET/READ and a picture using the multiple choice ("@M")
*-- function.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: CheckBx1(<lVar>,"<cTitle>",<nRow>,<nCol>)
*-- Example.....: lX = CheckBx1(.t.,"OK as is?",9,10)
*-- Returns.....: Logical
*-- Parameters..: lVar = On or Off to start? (.t.=on, .f.=off)
*-- cTitle = Title/Message
*-- nRow = Row to place this
*-- nCol = Column ...
*-------------------------------------------------------------------------------
parameters lVar, cTitle, nRow, nCol
*-- save parts of environment ...
cFormat = set("FORMAT")
set format to
cCursor = set("CURSOR")
set cursor off
*-- define starting value of cVar ...
*-- (this is ASCII 255, √, ASCII 255, if lVar = .t., 3 spaces if lVar = .f.)
cVar = iif(lVar,chr(255)+chr(251)+chr(255),space(3))
*-- display/get, using picture
@nRow,nCol get cVar picture "@M , √ "
*-- this picture is: space, comma, chr(255), chr(251), chr(255).
@nRow,nCol + 4 say cTitle
READ
*-- reset environment
set format to &cFormat
set cursor &cCursor
RETURN .not. (cVar = chr(32)) && not a space
*-- EoF: CheckBx1()
FUNCTION DropDown
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: This function performs a picklist of a different sort.
*-- In order to use it, you will either use an ARRAY (one-dim)
*-- or a field in a database. It holds a choice in a 'holding
*-- area', allowing the user to leave it there, and maybe to
*-- change it with another option in the list.
*--
*-- I recommend you display an on-screen message for this one,
*-- because it's not real intuitive (at least not to me).
*-- To bring up the list, click on the arrows, to select an item,
*-- click on the item, or highlight and press <enter>. To
*-- Change, click (or select) another item. To choose the actual
*-- item you want, click on the one NEXT to the arrows (or use
*-- the arrow keys to select that menu pad, and press <Enter>).
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- Calls.......: TEMPNAME() Function in WINDOWS.PRG
*-- ARRAYROWS() Function in WINDOWS.PRG
*-- ARRAYCOLS() Function in WINDOWS.PRG
*-- FIELDNUM() Function in WINDOWS.PRG
*-- Called by...: Any
*-- Usage.......: DropDown("<cType>","<cName>",[<nRow>,[<nCol>,[<nSize>]]])
*-- Example.....: x=DropDown("F","Lastname",10,15,6)
*--
*-- Here is a suggested use:
*-- @5,10 get cName when calldrop() && function below
*-- read
*-- *-- do other stuff
*-- FUNCTION CallDrop
*-- *-- display message about how to use
*-- @18,10 say "<Enter> or Click mouse on "+chr(23)+;
*-- " to see list"
*-- @19,10 say "<Enter> or Click mouse on name at top to select"
*-- *-- call it ... if using a FIELD in the database, you might
*-- *-- want to use a temp var, and then
*-- *-- REPLACE <field> WITH ...
*-- cName = dropdown("F","NAME",6,10,5) && call dropdown func.
*-- *-- redisplay it and clean out the 'gets' from memory
*-- @5,10 get cName
*-- clear gets
*-- keyboard chr(23) && move on to next field ...
*-- RETURN .T.
*--
*-- Returns.....: Selected item
*-- Parameters..: cType = 'F' = Field, 'A' = Array (1-Dimensional)
*-- cName = Field or Array name
*-- nRow = Coordinates to display menu
*-- nCol = Same
*-- nSize = Number of items to display below dropdown box
*-------------------------------------------------------------------------------
parameters cType, cName, nRow, nCol, nSize
*-- If these optional parms are NOT passed, we need to set default
*-- values ...
nSize = iif(pcount() <= 4, 5, nSize)
nCol = iif(pCount() <= 3,10, nCol)
nRow = iif(pCount() <= 2, 5, nRow)
*-- setup
nMaxLen = 1
lNone = (set("BORDER") = "NONE")
define menu mDropDown
*-- if it's an array, we work here for setup ...
if upper(cType) = "A"
nCols = arraycols(cName)
nRows = arrayrows(cName)
*-- determine width of display, by scanning each element of
*-- array and finding the largest ...
nX = 1
do while nX <= nCols
nMaxLen = Max(nMaxLen, len(&cName[nX]))
nX = nX + 1
enddo
*-- here we're gonna define the popup part of it ...
define popup pDropDown from nRow+iif(lNone,0,1),;
nCol-iif(lNone,1,0) to nRow+nSize+;
iif(lNone,1,2),nCol+nMaxLen+iif(lNone,0,1)
*-- define the bars ... the loops have to be done seperate,
*-- since the width must be determined before the bars are defined.
nX = 1
do while nX <= nCols
define bar nX of DropDown prompt &cName[nX]
nX = nX + 1
enddo
else
*-- process if it's a field here
do case
case type ("&cName") = "C" && character
calculate max(len(trim(&cName))) to nMaxLen
case type ("&cName") $ "FN" && numeric (or floating)
cAlias = alias()
dbftemp = tempname("DBF")
nNum = fieldnum(cName)
copy structure extended to (dbfTemp)
select select()
use (dbftemp) exclusive nosave
go nNum
nMaxLen = field_Len
use
select (cAlias)
case type ("&cName") = "D"
nMaxLen = iif(set("CENTURY") = "ON",10,8)
case type ("&cName") = "L"
nMaxLen = 1
endcase
define popup pDropdown from nRow + iif(lNone,0,1),nCol-;
iif(lNone,1,0) to nRow+nSize+iif(lNone,1,2),;
nCol+nMaxLen+iif(lNone,0,1) prompt field &cName
endif
*-- define the pad that activates this thing ...
define pad pPad2 of mDropDown prompt chr(23) at nRow,nCol+nMaxLen
on selection pad pPad2 of mDropDown activate popup pDropDown
on selection popup pDropDown deactivate menu
do while lastkey() # 27
xPrompt = trim(prompt())+space(nMaxLen - len(trim(prompt())))
define pad pPad1 of mDropDown prompt xPrompt at nRow,nCol
on selection pad pPad1 of mDropDown deactivate menu
activate menu mDropDown pad pPad2
if pad() = "PPAD1"
exit
endif
enddo
release popup pDropDown
release menu mDropDown
RETURN trim(prompt())
*-- EoF: DropDown()
FUNCTION MsWind
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: This one creates a window that acts like one from WINDOWS,
*-- in that you can move it, enlarge it to full-screen, and
*-- bring it back to its original size.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- Calls.......: MOVEWINU Procedure in WINDOWS.PRG
*-- MOVEWIND Procedure in WINDOWS.PRG
*-- ENLARGE Procedure in WINDOWS.PRG
*-- MSWINACT Procedure in WINDOWS.PRG
*-- Called by...: Any
*-- Usage.......: MsWind(<nTop>,<nLeft>,<nLower>,<nRight>)
*-- Example.....: x=MsWind(5,10,20,70)
*-- Returns.....: Logical
*-- Parameters..: nTop = Top Row of window
*-- nLeft = Left column
*-- nBottom = Bottom Row of Window
*-- nRight = Right column
*-------------------------------------------------------------------------------
parameters nTop, nLeft, nLower, nRight
*-- save environment
save screen to sMSWIND
lStatus = (set("STATUS") = "ON")
lDisp43 = ("43" $ SET("DISPLAY"))
*-- loop
do while .t.
restore screen from sMSWIND
*-- define/redefine window area and box
@nTop, nLeft clear to nLower, nRight
@nTop, nLeft TO nLower, nRight
*-- using menus to simulate Windows window ...
define menu wNormal
define pad pCabinet of wNormal prompt "["+chr(254)+"]";
at nTop, nLeft + 1 && ■
define pad pMoveUp of wNormal prompt chr(18) ;
at nTop, nRight - 4 && up/down-arrow
define pad pEnlarge of wNormal prompt chr(30) ;
at nTop, nRight - 1 && up-arrow-head
define pad pMoveDn of wNormal prompt chr(18) ;
at nLower, nRight - 4 && up/down arrow again
*-- tell it what to do when an item is selected
on selection pad pCabinet of wNormal deactivate menu
on selection pad pMoveUp of wNormal do movewinu
on selection pad pEnlarge of wNormal do enlarge
on selection pad pMoveDn of wNormal do movewind
*-- deal with changes ...
do mswinact with nTop, nLeft
activate menu wnormal
*-- User pressed <Esc> or chose the 'close window' button/pad
if lastkey() = 27 .or. "PCABINET" = pad()
exit
endif
enddo && end of loop
*-- restore environment
restore screen from sMSWIND
release screen sMSWIND
release menu wNormal
RETURN .not. "" = pad()
*-- EoF: MSWind()
PROCEDURE Enlarge
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: Used in MSWIND() to 'enlarge' the a window, and redfine
*-- the menu ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- Calls.......: MsWinAct Procedure in WINDOWS.PRG
*-- Called by...: MsWind() Function in WINDOWS.PRG
*-- Usage.......: Do Enlarge
*-- Example.....: Do Enlarge
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
*-- clear screen, draw border from upper left to a bottom right corner ...
clear
@0,0 to iif(lStatus,21,24) + iif(lDisp43,18,0), 79
*-- define new version of menu
define menu mEnlarge
define pad pCabinet of mEnlarge prompt "["+chr(254)+"]" at 0,2
define pad pReduce of mEnlarge prompt chr(31) at 0,78
on selection pad pCabinet of mEnlarge deactivate menu
on selection pad pReduce of mEnlarge deactivate menu
*-- Routine to allow interaction inside menu window ...
do mswinact with 0,0
*-- start 'er up
activate menu mEnlarge
deactivate menu
if lastkey() = 27
keyboard "{27}"
endif
release menu mEnlarge
clear
RETURN
*-- EoP: Enlarge
PROCEDURE MoveWinU
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: Used in MSWIND() to move the window up (unless the
*-- window is at the top of the screen ...)
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: MsWind() Function in WINDOWS.PRG
*-- Usage.......: Do MoveWinU
*-- Example.....: Do MoveWinU
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
*-- check for top of screen ... change coordinates
nTop = nTop - iif(nTop = 0,0,1)
nLower = nLower - iif(nTop = 0,0,1)
deactivate menu
RETURN
*-- EoP: MoveWinU
PROCEDURE MoveWinD
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: Used in MSWIND() to move the window down (unless the
*-- window is at the bottom of the screen ...)
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: MsWind() Function in WINDOWS.PRG
*-- Usage.......: Do MoveWinD
*-- Example.....: Do MoveWinD
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
*-- check for bottom of screen/status line ... change coordinates
nTop = nTop + iif(nLower = iif(lStatus,21,24)+;
iif(lDisp43,18,0),0,1)
nLower = nLower + iif(nLower=iif(lStatus,21,24)+;
iif(lDisp43,18,0),0,1)
deactivate menu
RETURN
*-- EoP: MoveWinD
PROCEDURE MSWinAct
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: Used in MSWIND() to move the actually display/redisplay
*-- information inside the window, even when a window has been
*-- moved. This routine should be modified for a specific
*-- system ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: MsWind() Function in WINDOWS.PRG
*-- Usage.......: Do MSWinAct with <nTop>, <nLeft>
*-- Example.....: Do MSWinAct with 5,10
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
parameters nTop, nLeft
private nTop, nLeft
@nTop + 2, nLeft + 2 say "This is line 1"
@nTop + 3, nLeft + 2 say "And this is line 2"
RETURN
*-- EoP: MSWinAct
FUNCTION RadioBut
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: This is a Radio Button routine. NOTE that the array called as
*-- cArray below must be a character array (i.e., all data must
*-- be character data ...).
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- Calls.......: ArrayRows() Function in WINDOWS.PRG
*-- TmpRadio Procedure in WINDOWS.PRG
*-- Called by...: None
*-- Usage.......: RadioBut("<cArray>",<nRow>,<nCol>,<nDefPad>,<nASCII>)
*-- Example.....: nReturn = RadioBut("aTest",5,10,1,15)
*-- Returns.....: Numeric (Array Index of item selected)
*-- Parameters..: cArray = Name of Array (Character data)
*-- nRow = Row for coordinates ... (start position)
*-- nCol = Column for same
*-- nDefPad = Default Pad number
*-- nASCII = ASCII character to use as 'button' (Optional ...)
*-- try: 4 (Diamond), 9 (Circle), 15 (splot), 42 (*), 249 (∙),
*-- 251 (√) or 254 (■) ...
*-------------------------------------------------------------------------------
parameters cArray, nRow, nCol, nDefPad, nASCII
define menu mRadio
public aTmpRadio, nARows, nPad
*-- get number of items to display
nARows = ArrayRows(cArray)
*-- set character for 'button'
nASCII = iif(PCOUNT() <= 4,4,nASCII) && default is a 'diamond'
*-- start definitions ...
cPad = iif(pcount() => 4 .and. nDefPad # 0, ltrim(str(nDefPad)),"1")
nCol = iif(pcount() <= 2,10,nCol)
nRow = iif(pCount() <= 1,5,nRow)
*-- here we get the largest item in the array ...
nX = 1
nLongest = 1
do while nX <= nARows
nLongest = max(nLongest,len(trim(&cArray[nX])))
nX = nX + 1
enddo
*-- define a temporary array ...
declare aTmpRadio[nARows]
on key label ctrl-m keyboard "{27}" && close down if <Enter> ...
cX = "1"
do while .t.
*-- define menu pads
do while val(cX) <= nARows
define pad button&cX of mRadio at nRow - 1 + val(cX),nCol;
prompt "("+ iif(aTmpRadio[val(cX)] .or. cPad = cX,;
chr(nASCII)," ")+") "+trim(&cArray[val(cX)])+;
space(nLongest-len(trim(&cArray[val(cX)])))
on selection pad button&cX of mRadio deactivate menu
cX = ltrim(str(val(cX)+1))
enddo
*-- start 'er up
activate menu mRadio pad button&nPad
*-- if <Esc> (or <Enter>), we're done ...
if lastkey() = 27
nPad = substr(pad(),7)
exit
else
*-- if not, perform routine below to reset the temp array ...
do TmpRadio
endif
enddo
*-- cleanup
on key label ctrl-m
ny = 1
do while ny <= nARows .and. .not. aTmpRadio[nY]
nY = nY + 1
enddo
release aTmpRadio, nPad
release menu mRadio
RETURN iif(nY > nARows, 0, nY)
*-- EoF: RadioBut()
PROCEDURE TmpRadio
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: Used to set/reset the temporary array aTmpRadio[] for use
*-- in the RadioBut() function above.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: RadioBut() Function in WINDOWS.PRG
*-- Usage.......: Do TmpRadio
*-- Example.....: Do TmpRadio
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
nPad = substr(pad(),7)
nY = 1
do while nY <= nARows
aTmpRadio[nY] = .f.
nY = nY + 1
enddo
aTmpRadio[val(nPad)] = .t.
cX = "1"
RETURN
*-- EoP: TmpRadio
FUNCTION ScrolBar
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/01/1992
*-- Notes.......: Performs a horizontal scroll-bar to find a record in a
*-- database file. Note that this function assumes a database
*-- is open. Not quite sure how I'd use this one ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: None
*-- Usage.......: ScrolBar(<nAtLine>)
*-- Example.....: This example is from the text of Adam's article:
*-- Add the following line to your program or FMT file:
*--
*-- ON KEY LABEL F5 DO MoveRec
*--
*-- Create a simple PROCEDURE or program with the following:
*--
*-- PROCEDURE MoveRec
*-- on key label ctrl-M chr(27) && press <Enter> to return
*-- x=scrolbar(20) && call function
*-- on key label ctrl-M && reset CTRL-M key
*-- RETURN
*--
*-- Returns.....: .T.
*-- Parameters..: nAtLine = Line of screen (ROW) to display scroll bar at.
*-------------------------------------------------------------------------------
parameters nAtLine
nAtLine = iif(pCount() = 1, nAtLine, 20)
nBreak = 76
cx = "1"
ny = 1
nRecord = reccount()
nZ = (nBreak/nRecord) - int(nBreak/nRecord)
*-- once again, this is being done via a menu ...
define menu mScrollBar
define pad pPad0 of mScrollBar prompt chr(17) at nAtLine, 1
*-- if the first pad is selected, back up one record
on selection pad pPad0 of mScrollBar skip iif(bof(),0,-1)
*-- deal with location of the rest ...
do while val(cX) <= nRecord
if nRecord <= nBreak
define pad pPad&cX of mScrollBar ;
prompt;
space((nBreak/nRecord)+iif(nZ => 1, int(nZ),0)) at nAtLine, nY + 1
endif
nY = nY + int(nBreak/nRecord)+iif(nZ => 1, int(nZ),0)
if nZ => 1
nZ = nZ - int(nZ)
endif
nZ = nZ + (nBreak / nRecord) - int(nBreak/nRecord)
on selection pad pPad&cX of mScrollBar go val(substr(pad(),4))
cX = ltrim(str(val(cX) + 1))
enddo
*-- define final pad
define pad pPad&cX of mScrollBar prompt chr(16) at nAtLine, nY + 1
on selection pad pPad&cX of mScrollBar skip iif(eof(),0,1)
*-- start 'er up ...
activate menu mScrollBar
RETURN .t.
*-- EoF: ScrolBar()
*-------------------------------------------------------------------------------
*-- This section is where I, Ken Mayer, attempted to modify/improve some of
*-- Adam's routines ... I may or may not have been successful, YOU decide ...
*-- <g>
*-------------------------------------------------------------------------------
FUNCTION Alert2
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 11/09/1992
*-- Notes.......: This routine creates a popup on the screen with a title and
*-- one line message, forcing the user to notice the message.
*-- The user must use the mouse on the 'OK' pad, press <Esc> or
*-- press <Enter> to move on in the program that called this
*-- function.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/19/1992 -- Modified to accept the <Enter> key by Ken Mayer.
*-- 06/19/1992 -- Copied from Adam's original, uses a window,
*-- shadow, and programmer defineable colors.
*-- 07/29/1992 -- Joey stepped in and made some modifications
*-- that seem to have helped as well, including dealing with
*-- the keyboard buffer.
*-- 10/09/1992 -- minor change -- title is now same color as
*-- the "pad".
*-- 11/09/1992 -- Joey Carroll added some minor changes for
*-- cosmetics, as well as keeping the colors working
*-- properly.
*-- Calls.......: SHADOW Procedure in PROC.PRG
*-- CENTER Procedure in PROC.PRG
*-- JUSTIFY() Function in WINDOWS.PRG
*-- Called by...: Any
*-- Usage.......: Alert2("<cTitle>","<cMessage>","<cColor>")
*-- Example.....: lX = Alert2("Print Aborted","You pressed <ESC>",;
*-- "rg+/r,w+/b,rg+/r")
*-- Returns.....: Logical
*-- Parameters..: cTitle = Title line
*-- cMessage = One line message (up to 75 characters)
*-- cColor = Colors: <window forg/back>,<pad> (and title),<box>
*-------------------------------------------------------------------------------
parameters cTitle, cMessage, cColor
private wWindow,nRow,nCol,mPad,cTempCol
wWindow = WINDOW() && save current Window
save screen to sTemp && save the screen
i=inkey() && clear out keyboard buffer
*-- get window coordinates
*-- this centers from top to bottom, depending on monitor setup ...
nULRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8)
*-- add 6, so the Window is large enough ...
nBRRow = nULRow + 6
*-- left column ...
nULCol = 36 - (max(len(cTitle),len(cMessage))/2) && center left-right
*-- right column ...
nBRCol = nULCol + max(len(cTitle),len(cMessage))+4 && right side?
*-- Window width ...
nWidth = nBRCol - nULCol - 1
*-- define window
Define window wAlert from nULRow,nULCol to nBRRow,nBRCol DOUBLE ;
color &cColor.
activate screen
*-- display shadow
do shadow with nULRow,nULCol,nBRRow,nBRCol
*-- start 'er up ...
activate window wAlert
*-- display title
cTempCol = colorbrk(cColor,2)
if len(cTitle) < nWidth
cTitle = justify(cTitle,nWidth,"C")
if len(cTitle) < nWidth
cTitle = cTitle + " "
endif
endif
do center with 0,nWidth,"&cTempCol",cTitle
*-- display line
cTempCol = colorbrk(cColor,1)
@1,0 say replicate(chr(196),nWidth) color &cTempCol
*-- display message
do center with 2,nWidth,"",cMessage
*-- define/display a very small menu (one pad)
define menu mAlert
define pad pPad1 of mAlert prompt "[OK]" at 4,(nWidth/2)-1
on selection pad pPad1 of mAlert deactivate menu
*-- added by Ken to deal with <Enter>
on key label ctrl-M keyboard "{27}"
*-- start it up
activate menu mAlert
*-- deal with user 'input'
mPad = pad()
deactivate window wAlert
release window wAlert
*-- restore environment, free up RAM by releasing things
on key label ctrl-m
restore screen from sTemp
release screen sTemp
release menu mAlert
if "" # wWindow
activate window &wWindow
endif
RETURN .not. "" = mPad && not empty pad?
*-- EoF: Alert2()
FUNCTION MsWind2
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/23/1992
*-- Notes.......: This one creates a window that acts like one from WINDOWS,
*-- in that you can move it, enlarge it to full-screen, and
*-- bring it back to its original size.
*-- NOTE: The Title is NOT displaying in the EXPANDED Window.
*-- This is based on a KNOWN BUG, forwarded to development.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/23/1992 -- Ken Mayer -- Attempts made to use a 'real'
*-- window (a dBASE defined window), shadows, colors, and make
*-- the window look more like a Microsoft Windows Window.
*-- Calls.......: MOVEWIN2 Procedure in WINDOWS.PRG
*-- ENLARGE2 Procedure in WINDOWS.PRG
*-- MSWINAC2 Procedure in WINDOWS.PRG
*-- SHADOW Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: MsWind2(<nTop>,<nLeft>,<nLower>,<nRight>,"<cColor>",;
*-- "<cTitle>")
*-- Example.....: x=MsWind2(5,10,20,70,"rg+/gb,w+/b,rg+/gb","This is a title")
*-- Returns.....: Logical
*-- Parameters..: nTop = Top Row of window
*-- nLeft = Left column
*-- nBottom = Bottom Row of Window
*-- nRight = Right column
*-- cColor = Color combinations to be used:
*-- <Normal/Unselected pad>,<Selected pad>,<Box>
*-- cTitle = Title for first line of window ...
*-- NOTE: if the title is longer than can be displayed
*-- with the buttons on the first line, it will be
*-- truncated ...
*-------------------------------------------------------------------------------
parameters nTop, nLeft, nLower, nRight, cColor, cTitle
*-- save environment
save screen to sMSWIND
lStatus = (set("STATUS") = "ON")
lDisp43 = ("43" $ SET("DISPLAY"))
cMSColor = set("ATTRIBUTES")
*-- loop
do while .t.
*-- bring back old screen before defining all this
if window() = "WMSWIND"
deactivate window wMSWIND
endif
restore screen from sMSWIND
*-- define/redefine window area and box
activate screen
define window wMSWind from nTop,nLeft to nLower,nRight double;
color &cColor
do shadow with nTop,nLeft,nLower,nRight
activate window wMSWind
*-- deal with defining where to display the title (and truncating
*-- if necessary)
*-- define width and height of window
nWidth = nRight - nLeft - 2 && account for border
nHeight = nLower - nTop - 2 && ditto
nWidth2 = nWidth - 9 && (space used by menu buttons)
if len(trim(cTitle)) > (nWidth2 - 2) && leave room for a space on each sd
cTitle2 = left(cTitle,nWidth2-2)
else
cTitle2 = trim(cTitle)
endif
nSpaces = nWidth2 - len(cTitle2)
nSpaces1 = nSpaces/2
nSpaces2 = iif(nSpaces1=int(nSpaces/2),nSpaces1,nSpaces1+1)
cTitle2 = space(nSpaces1) + cTitle2 + space(nSpaces2)
cTitlCol = colorbrk(cColor,2)
@0,3 say cTitle2 color &cTitlCol
*-- using menus to simulate Windows window ...
define menu wNormal
define pad pCabinet of wNormal prompt "["+chr(254)+"]" at 0, 0
define pad pMoveUp of wNormal prompt "["+chr(24)+"]" at 0,nWidth - 6
define pad pEnlarge of wNormal prompt "["+chr(30)+"]" at 0,nWidth - 3
define pad pMoveDn of wNormal prompt "["+chr(25)+"]" ;
at nHeight, nWidth - 3
define pad pMoveRt of wNormal prompt "["+chr(26)+"]" ;
at nHeight, nWidth - 6
define pad pMoveLf of wNormal prompt "["+chr(27)+"]" ;
at nHeight, nWidth - 9
*-- tell it what to do when an item is selected
on selection pad pCabinet of wNormal deactivate menu
on selection pad pMoveUp of wNormal do movewin with pad()
on selection pad pEnlarge of wNormal do enlarge2 with cTitle, cTitlCol
on selection pad pMoveDn of wNormal do movewin with pad()
on selection pad pMoveRt of wNormal do movewin with pad()
on selection pad pMoveLf of wNormal do movewin with pad()
*-- Display something in Window
do mswinat2
*-- start the menu
activate menu wnormal
*-- User pressed <Esc> or chose the 'close window' button/pad
if lastkey() = 27 .or. "PCABINET" = pad()
exit
endif
enddo && end of loop
*-- restore environment
deactivate window wMSWind
release window wMSWind
restore screen from sMSWIND
release screen sMSWIND
release menu wNormal
RETURN .not. "" = pad()
*-- EoF: MSWind()
PROCEDURE Enlarge2
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/23/1992
*-- Notes.......: Used in MSWIND() to 'enlarge' the a window, and redfine
*-- the menu ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/23/1992 -- Ken Mayer (CIS: 71333,1030) - redefined to handle
*-- using real dBASE Windows ...
*-- Calls.......: MsWinAt2 Procedure in WINDOWS.PRG
*-- Called by...: MsWind2() Function in WINDOWS.PRG
*-- Usage.......: Do Enlarge2 with cTitle, cTitlCol
*-- Example.....: Do Enlarge2 with cTitle, cTitlCol
*-- Returns.....: None
*-- Parameters..: cTitle = Title from MSWIND2()
*-- cTitlCol = Title color (also from MSWIND2())
*-------------------------------------------------------------------------------
parameters cTitle, cTitlCol
*-- do a new version of the window ...
deactivate window wMSWind
restore screen from sMSWIND
activate screen
define window wMSWind from 0,0 to iif(lStatus,20,23) + iif(lDisp43,18,0), 77;
double color &cColor
do shadow with 0,0,iif(lstatus,20,23)+iif(lDisp43,18,0),77
activate window wMSWind
*-- deal with TITLE ...
*-- deal with defining where to display the title (and truncating
*-- if necessary)
*-- define width and height of window
nWidth = 74 && account for border
nWidth2 = nWidth - 6 && (space used by menu buttons)
if len(trim(cTitle)) > (nWidth2 - 2) && leave room for a space on each side
cTitle2 = left(cTitle,nWidth2-2)
else
cTitle2 = trim(cTitle)
endif
nSpaces = nWidth2 - len(cTitle2)
nSpaces1 = nSpaces/2
nSpaces2 = iif(nSpaces1=int(nSpaces/2),nSpaces1,nSpaces1+1)
cTitle2 = space(nSpaces1) + cTitle2 + space(nSpaces2)
@0,3 say cTitle2 color &cTitlCol
*-- define new version of menu
define menu mEnlarge
define pad pCabinet of mEnlarge prompt "["+chr(254)+"]" at 0,0
define pad pReduce of mEnlarge prompt "["+chr(31)+"]" at 0,72
on selection pad pCabinet of mEnlarge deactivate menu
on selection pad pReduce of mEnlarge deactivate menu
*-- Routine to allow interaction inside menu window ...
do mswinat2
*-- start 'er up
activate menu mEnlarge
if lastkey() = 27
keyboard "{27}"
endif
deactivate menu
deactivate window wMSWIND
release window wMSWIND
release menu mEnlarge
RETURN
*-- EoP: Enlarge2
PROCEDURE MoveWin
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 06/23/1992
*-- Notes.......: Used in MSWIND() to move the window up (unless the
*-- window is at the top of the screen ...)
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/23/1992 -- Original
*-- Calls.......: None
*-- Called by...: MsWind() Function in WINDOWS.PRG
*-- Usage.......: Do MoveWin with <pPad>
*-- Example.....: Do MoveWin with pad()
*-- Returns.....: None
*-- Parameters..: pPad = menu pad selected to move window ...
*-------------------------------------------------------------------------------
parameters pPad
restore screen from sMSWIND
do case
case pPad = "PMOVEUP"
*-- check for top of screen ... change coordinates
nTop = nTop - iif(nTop = 0,0,1)
nLower = nLower - iif(nTop = 0,0,1)
case pPad = "PMOVEDN"
nTop = nTop + iif(nLower = iif(lStatus,21,24)+;
iif(lDisp43,18,0),0,1)
nLower = nLower + iif(nLower=iif(lStatus,21,24)+;
iif(lDisp43,18,0),0,1)
case pPad = "PMOVELF"
nLeft = nLeft - iif(nLeft = 0,0,1)
nRight = nRight - iif(nLeft = 0,0,1)
case pPad = "PMOVERT"
nRight = nRight + iif(nRight = 79,0,1)
nLeft = nLeft + iif(nRight = 79,0,1)
endcase
deactivate menu
RETURN
*-- EoP: MoveWin
PROCEDURE MSWinAt2
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (BORLAND TECHNICAL SUPPORT)
*-- Date........: 06/23/1992
*-- Notes.......: Used in MSWIND2() to move the actually display/redisplay
*-- information inside the window, even when a window has been
*-- moved. This routine should be modified for a specific
*-- system ... This version (for MSWIND2()) starts counting
*-- at the top + 1 -- the first line (0) is for the menu and
*-- the title ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Original
*-- 06/23/1992 -- Modified by Ken Mayer to work with MSWIND2().
*-- Calls.......: None
*-- Called by...: MsWind2() Function in WINDOWS.PRG
*-- Usage.......: Do MSWinAt2
*-- Example.....: Do MSWinAt2
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
@1,1 say "This is line 1"
@2,1 say "And this is line 2"
RETURN
*-- EoP: MSWinAt2
FUNCTION Alert3
*-------------------------------------------------------------------------------
*-- Programmer..: Adam L. Menkes (SUPREME1)
*-- Date........: 12/23/1992
*-- Notes.......: This function based on Alert2()
*-- This routine creates a popup on the screen with a title and
*-- one line message, forcing the user to notice the message.
*-- The user must use the mouse on the 'OK' pad, press <Esc> or
*-- press <Enter> to move on in the program that called this
*-- function.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: Original: 06/19/1992
*-- Alert2()
*-- Modified to accept the <Enter> key by Ken Mayer.
*-- 06/19/1992 -- Copied from Adam's original, uses a window,
*-- shadow, and programmer defineable colors.
*-- 07/29/1992 -- Joey stepped in and made some modifications
*-- that seem to have helped as well, including dealing with
*-- the keyboard buffer.
*-- 10/09/1992 -- minor change -- title is now same color as
*-- the "pad".
*-- Alert22()
*-- 11/12/1992 -- changed to look more like a Win 3.0/3.1
*-- window by printing a special 'line' below the title.
*-- Also removed hard coding which forced border to DOUBLE
*-- so that if called with border set to NONE, gives even more
*-- Win-like appearance. Calls a new function written for this
*-- technique, but can be used in other programs.
*-- 11/16/1992 -- modified to add cBORDER parameter ... (K. Mayer)
*-- 12/23/1992 -- tuned up centering of cTitle, cMessage, and
*-- [OK] pad. Eliminated calls to Center.prg by using Justify()
*-- along with @ say. (Joey Carroll)
*-- Calls.......: SHADOW Procedure in PROC.PRG
*-- JUSTIFY() Function in PROC.PRG
*-- COLORBRK() Function in PROC.PRG
*-- FBCLRBRK() Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: Alert2("<cTitle>","<cMessage>","<cColor>"[,"<cBorder>"])
*-- Example.....: ** if no border, I suggest colors which will contrast
*-- with the active screen or window
*-- lX = Alert2("Print Aborted","You pressed <ESC>",;
*-- "rg+/r,w+/b,rg+/r","NONE")
*-- Returns.....: Logical
*-- Parameters..: cTitle = Title line
*-- cMessage = One line message (up to 75 characters)
*-- cColor = Colors: <window forg/back>,<pad> (and title),<box>
*-- cBorder = Border type (DOUBLE, SINGLE, NONE, PANEL) --
*-- optional -- will default to your setting
*-------------------------------------------------------------------------------
parameters cTitle, cMessage, cColor, cBorder
private wWindow,mPad,cTempCol,cColorF,cColorB,cColorAll
private nWidth,nULRow,nULCol,nLRRow,nLRCol,cTitle2,cMessage2,nBorder
cTitle2 = " " + ltrim(trim(cTitle)) + " " && don't jamb against walls
cMessage2 = " " + ltrim(trim(cMessage)) + " " && don't jamb against walls
wWindow = WINDOW() && save current Window
save screen to sTemp && save the screen
activate screen
cDummykey = inkey() && clear out keyboard buffer
cOldBorder = set("BORDER") && get old border setting
if .not. type("CBORDER") = "L" && if user set border ...
set border to &cBorder && start NEW border setting
endif
nBorder = iif(set("BORDER") = "NONE",0,2) && border factor
*-- get window coordinates
*-- this centers from top to bottom, depending on monitor setup ...
nULRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8)
*-- add rows, number depends on border, so the Window is large enough ...
nBRRow = nULRow + 5 +nBorder
*-- left column ...
nULCol = 40 - (max(len(cTitle2),len(cMessage2))/2) && center left-right
*-- right column ...
nBRCol = nULCol + max(len(cTitle2),len(cMessage2)) + (nBorder - 1)
*-- Window width ...
nWidth = nBRCol - nULCol - 1
*-- define window
Define window wAlert from nULRow,nULCol to nBRRow,nBRCol color &cColor.
*-- display shadow
do shadow with nULRow,nULCol,nBRRow,nBRCol
*-- start 'er up ...
activate window wAlert
*-- display a new type type line to look more like Win
cTempCol = colorbrk(cColor,2)
cColorF = FBClrBrk("B",cTempCol) && background of title bar text
cColorB = FBClrBrk("B",colorbrk(cColor,1)) && foreground of 'normal' text
cColorAll = cColorF + "/" + cColorB && color of 'special' line
@ 0,0 say justify(cTitle2,nWidth + iif(nBorder = 0,4,2),"C") ;
color &cTempCol && the Title Bar
*-- chr(223) looks like this --> ▀ <--
@ 1,0 say replicate(chr(223),nWidth + 2) color &cColorAll && make thicker
*-- display message
@ 2,0 say justify(cMessage2,nWidth + iif(nBorder = 0,4,2),"C")
*-- define/display a very small menu (one pad)
define menu mAlert
define pad pPad1 of mAlert prompt "[OK]" at 4,((nWidth-nBorder-2)/2)
on selection pad pPad1 of mAlert deactivate menu
*-- added by Ken to deal with <Enter>
on key label ctrl-M keyboard "{27}"
*-- start it up
activate menu mAlert
*-- deal with user 'input'
mPad = pad()
deactivate window wAlert
release window wAlert
*-- restore environment, free up RAM by releasing things
on key label ctrl-m
restore screen from sTemp
release screen sTemp
release menu mAlert
if "" # wWindow
activate window &wWindow
endif
set border to &cOldBorder
RETURN .not. "" = mPad && not empty pad?
*-- EoF: Alert3()
FUNCTION YesNo3
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer
*-- Date........: 01/06/1993
*-- Notes.......: A version of the YESNO() routines in PROC.PRG, that will
*-- handle a long (up to 254 character) message string, is
*-- centered on the screen, and has a title bar kind of like
*-- a Windows dialog box ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/06/1993 -- Original
*-- Calls.......: Center Procedure in PROC.PRG
*-- Shadow Procedure in PROC.PRG
*-- WordWrap Procedure in STRINGS.PRG
*-- ColorBrk() Function in PROC.PRG
*-- FBClrBrk() Function in PROC.PRG
*-- Justify() Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: YesNo3(<lDefault>,<cTitle>,<cMessage>,<cColor>)
*-- Example.....: if YesNo3(.t.,"Test","This is a message of any length"+;
*-- "up to 254 characters.",cWind1)
*-- Returns.....: logical
*-- Parameters..: lDefault = Logical value, for the default menu pad (Yes/No)
*-- cTitle = Title for title bar -- no longer than 30
*-- characters.
*-- cMessage = Message - up to 254 characters in length.
*-- cColor = "Standard" colors for window/menu/box
*-------------------------------------------------------------------------------
parameters lDefault, cTitle, cMessage, cColor
private nULRow, nULCol, nBRRow, nBRCol, nLMargin, nRMargin, lWrap
*-- save it, so we can activate the screen and display a window on top
*-- of whatever's there
save screen to sYesNo
*-- save window if there is one, and activate screen to be safe:
wWindow = window()
activate screen
*-- now to define the coordinates ...
nULCol = 20 && left side of box
nBRCol = 60 && right side of box
nWidth = 36 && width of dialog box ... 36 characters for text
nHeight = int(len(cMessage)/nWidth)
*-- if the remainder of the length of the message/width of box is > 0
*-- we have one more line of text ...
nHeight = nHeight + iif(mod(len(cMessage),nWidth)>0,1,0)
*-- deal with room for title, and menu at bottom
nHeight = nHeight + 4
*-- row coordinates
nULRow = (24-nHeight) / 2 && top row
nBRRow = nULRow + nHeight + 1
*-- define the window
define window wYesNo from nULRow,nULCol to nBRRow,nBRCol double color &cColor
*-- now for the menu pads
define menu mYesNo
define pad pYes of mYesNo prompt "[Yes]" at nHeight - 1,10
define pad pNo of mYesNo prompt "[No]" at nHeight - 1,25
on selection pad pYes of mYesNo deactivate menu
on selection pad pNo of mYesNo deactivate menu
*-- display it
do shadow with nULRow,nULCol,nBRRow,nBRCol
activate window wYesNo
*-- display title
if len(cTitle) < nWidth
cTitle = justify(cTitle,39,"C")
if len(cTitle) < 39
cTitle = cTitle + " "
endif
endif
cTempCol = colorbrk(cColor,2)
cColorF = FBClrBrk("B",cTempCol)
cColorB = FBClrBrk("B",colorbrk(cColor,1))
cColorAll = cColorF + "/" + cColorB
@0,0 say cTitle color &cTempCol
@1,0 say replicate(chr(223),39) color &cColorAll
*-- display message
do WordWrap with 2,2,cMessage,35
*-- set Y/N keys for menu pad
clear typeahead && just to be safe
on key label Y keyboard iif(pad() = "PYES","",chr(19))+chr(13)
on key label N keyboard iif(pad() = "PNO", "",chr(4) )+chr(13)
*-- activate the menu
if lDefault
activate menu mYesNo pad pYes
else
activate menu mYesNo pad pNo
endif
*-- reset system
on key label Y
on key label N
deactivate window wYesNo
release window wYesNo
restore screen from sYesNo
release screen sYesNo
release menu mYesNo
if .not. isblank(wWindow)
activate window &wWindow
endif
RETURN iif(pad() = "PYES",.t.,.f.)
*-- EoF: YesNo3()
*-------------------------------------------------------------------------------
*-- These functions are here so that we don't have to go hunting all over
*-------------------------------------------------------------------------------
FUNCTION TempName
*-------------------------------------------------------------------------------
*-- Programmer..: Martin Leon (HMAN) Former Sysop, ATBBS
*-- Date........: 05/27/1992
*-- Notes.......: Obtain a name for a temporary file of a given extension
*-- that does not conflict with existing files.
*-- Written for.: dBASE IV, v1.5
*-- Rev. History: Originally part of Makestru(), 6-12-1991
*-- 04/26/92, made a separate function - Jay Parsons
*-- 05/27/92, added lDBTMP option - Bowen Moursund
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: TempName( cExt , lDBTMP )
*-- Example.....: Sortfile = TempName( "DBF" , .t. )
*-- Returns.....: Name not already in use. Additionally, if the memvar
*-- cDBTMP is declared before calling the function with
*-- the lDBTMP option, it will be assigned the result
*-- of getenv("DBTMP").
*-- Parameters..: cExt = Extension to be given file ( without the "." )
*-- lDBTMP = Optional. If .t., function returns unique file
*-- name in the DBTMP subdirectory.
*-- Side Effects: The function will return a unique filename for the DEFAULT
*-- subdirectory if the lDBTMP option is used and the DOS
*-- environment variable DBTMP does not point to a valid
*-- subdirectory.
*-------------------------------------------------------------------------------
parameters cExt, lDBTMP
private all except cDBTMP
cDefDir = set("DIRECTORY")
if lDBTMP
cDBTMP = getenv("DBTMP")
if "" # cDBTMP
set directory to &cDBTMP.
endif
endif
do while .t.
Fname = "TMP" + ltrim( str( rand() * 100000, 5 ) )
if .not. file( Fname + "." + cExt ) .and. ( upper( cExt ) # "DBF" .or.;
.not. ( file( Fname + ".MDX" ) .or. file ( Fname + ".DBT" ) ) )
exit
endif
enddo
set directory to &cDefDir.
RETURN Fname
*-- Eof() TempName
FUNCTION ArrayRows
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Number of Rows in an array
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 03/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ArrayRows("<aArray>")
*-- Example.....: n = ArrayRows("aTest")
*-- Returns.....: numeric
*-- Parameters..: aArray = Name of array
*-------------------------------------------------------------------------------
parameters aArray
private nHi, nLo, nTrial, nDims
nLo = 1
nHi = 1170
if type( "&aArray[ 1, 1 ]" ) = "U"
nDims = 1
else
nDims = 2
endif
do while .T.
nTrial = int( ( nHi + nLo ) / 2 )
if nHi < nLo
exit
endif
if nDims = 1 .and. type( "&aArray[ nTrial ]" ) = "U" .or. ;
nDims = 2 .and. type( "&aArray[ nTrial, 1 ]" ) = "U"
nHi = nTrial - 1
else
nLo = nTrial + 1
endif
enddo
RETURN nTrial
*-- EoF: ArrayRows()
FUNCTION ArrayCols
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Number of Columns in an array
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 03/01/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ArrayCols("<aArray>")
*-- Example.....: n = ArrayCols("aTest")
*-- Returns.....: numeric
*-- Parameters..: aArray = Name of array
*-------------------------------------------------------------------------------
parameters aArray
private nHi, nLo, nTrial
nLo = 1
nHi = 1170
if type( "&aArray[ 1, 1 ]" ) = "U"
RETURN 0
endif
do while .t.
nTrial = int( ( nHi + nLo ) / 2 )
if nHi < nLo
exit
endif
if type( "&aArray[ 1, nTrial ]" ) = "U"
nHi = nTrial - 1
else
nLo = nTrial + 1
endif
enddo
RETURN nTrial
*-- EoF: ArrayCol()
FUNCTION FieldNum
*-------------------------------------------------------------------------------
*-- Programmer..: ?
*-- Date........: 03/09/1992
*-- Notes.......: Designed to return the number of a given fieldname in the
*-- database structure. Works on open database only ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/01/1992 -- Adam L. Menkes for 1.5 ...
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: FieldNum("<cFldName>")
*-- Example.....: n = FieldNum("Firstname")
*-- Returns.....: Numeric
*-- Parameters..: cFldName = Name of Field
*-------------------------------------------------------------------------------
Parameters cFldName
cExact = set("EXACT")
set exact on
nField = 1
do while upper(cFldName) <> FIELD(nField) .and. nField <= fldcount()
nField = nField + 1
enddo
set exact &cExact
RETURN iif(len(trim(field(nField))) = 0,0,nField)
*-- EoF: FieldNum()
FUNCTION Justify
*-------------------------------------------------------------------------------
*-- Programmer..: Roland Bouchereau (Ashton-Tate)
*-- Date........: 12/23/1992
*-- Notes.......: Used to pad a field/string on the right, left or both,
*-- justifying or centering it within the length specified.
*-- If the length of the string passed is greater than
*-- the size needed, the function will truncate it.
*-- Taken from Technotes, June 1990. Defaults to Left Justify
*-- if invalid TYPE is passed ...
*-- Written for.: dBASE IV, 1.0
*-- Rev. History: Original function 06/15/1991
*-- 12/17/1991 -- Modified into ONE function from three by
*-- Ken Mayer, added a third parameter to handle that.
*-- 12/23/1992 -- Modified by Joey Carroll to use STUFF()
*-- instead of TRANSFORM().
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Justify(<cFld>,<nLength>,"<cType>")
*-- Example.....: ?? Justify(Address,25,"R")
*-- Returns.....: Padded/truncated field
*-- Parameters..: cFld = Field/Memvar/Character String to justify
*-- nLength = Width to justify within
*-- cType = Type of justification: L=Left, C=Center,R=Right
*-------------------------------------------------------------------------------
parameters cFld,nLength,cType
private cReturn
cType = upper(cType) && just making sure ...
if type("cFld")+type("nLength")+type("cType") $ "CNC,CFC"
*-- set a picture function of 'X's, with @I,@J or @B function
cReturn = space(nLength)
cReturn = stuff(cReturn,;
iif(cType = "C",(nLength-len(cFld))/2,;
iif(cType = "R",nLength-len(cFld)+1,1)),;
len(cFld),cFld)
else
cReturn = ""
endif
RETURN cReturn
*-- EoF: Justify()
PROCEDURE WordWrap
*-------------------------------------------------------------------------------
*-- Programmer..: David Frankenbach (CIS: 72147,2635)
*-- Date........: 01/14/1993 (Version 1.1)
*-- Notes.......: Wraps a long string, breaking it into strings that have
*-- a maximum length of nWidth. The first output is displayed
*-- @nRow, nCol. Words are not split ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/06/1993 -- Original Release (Version 1.0)
*-- 01/14/1993 -- Version 1.1 -- Corrected side-effect of
*-- destroying string arg, added test for
*-- string[nWidth+1] = " "
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do WordWrap with <nRow>, <nCol>, <cString>, <nWidth>
*-- Example.....: do WordWrap with 2,2,cText,38
*-- Returns.....: None
*-- Parameters..: nRow = Row to display first line at
*-- nCol = Left side of area to display text at
*-- cString = text to wrap
*-- nWidth = Width of area to wrap text in
*-------------------------------------------------------------------------------
parameters nRow, nCol, cString, nWidth
private cTemp, nI, cStr
cStr = cString && work with a COPY of input, to avoid
&& destroying original
do while len(cStr) > 0 && while there's something to work on
if (nWidth < len(cStr))
nI = nWidth && look for last " " in first nWidth
if substr(cStr,nI+1,1) # " "
do while ( (nI > 0) .and. (substr(cStr,nI,1) # " ") )
nI = nI - 1
enddo
endif
if nI = 0 && no spaces
nI = nWidth && get first nWidth characters
endif
else
nI = len(cStr) && use the rest of the string
endif
cTemp = left(cStr,nI) && get the part we're going to display
if nI < len(cStr) && remove that part
cStr = ltrim(substr(cStr,nI + 1))
else
cStr = ""
endif
*-- display it
@nRow,nCol say cTemp
*-- move to next row
nRow = nRow + 1
enddo
RETURN
*-- EoP: WordWrap
*-------------------------------------------------------------------------------
*-- End of Program: WINDOWS.PRG
*-------------------------------------------------------------------------------